Languguage OS 2/Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO/language/embedded/mcu/float09.arc/OUTS.SA

Text File | 1987-03-04 | 22KB | 998 lines

  NAM  OUTS
 TTL  BINARY TO DECIMAL STRING CONVERSION
*
* LINKING LOADER DEFINITIONS
*
 XREF FPMOVE,PWRTEN,FFIX,FMUL,FDIV,FADD,FSUB,MAGCMP
 XREF LOG10X,DNORM1,ONE,CLRES,ROUND,DENORM,TFRACT
 XREF ARG1UN,LNORM,IOPSUB,IOPSET,GETINT
*
 XDEF BDCNVT,OUTNDC,BCDINC,BCDUBL,BINSTR
*
* REVISION HISTORY:
*
*   DATE    PROGRAMMER     REASON
*
*  28.MAY.80    G. STEVENS &   ORIGINAL
*        G. WALKER
*  12.JUN.80    G. STEVENS     FIX NEGD IN BINDEC &
*                   V AS ARGUMENT TO SPCASE
*  16.JUN.80    G. STEVENS     RESTORE V AFTER RTS FROM SPCASE
*  17.JUL.80    G. WALKER      CODE SHRINK (XREF ONE, ETC.)
*  18.JUL.80    G. STEVENS     ADD NON DECIMAL PROCEDURE OUTNDC
*  05.AUG.80    G. STEVENS     ADD CODE TO HANDLE P ON OUTS
*  13.AUG.80    G. WALKER      SAVE BYTES BY USING 'ROUND' IN
*                  BINSTR
*  21.AUG.80    G. STEVENS     REWORK LOG10X PART OF OUTS
*  26.AUG.80    G. STEVENS     CLEAR INX FLAG IN BDCNVT AND
*                   INVOKE ARG1UN IN SPCASE
*  27.AUG.80    J. BONEY       ADD CODE TO VALIDATE K
*  28.OCT.80    G. STEVENS     FIX STACK OFFSET IN BDCNVT
*  03.DEC.80    G. STEVENS     REMOVE LNORM CALL IN OUTS
*  03.DEC.80    G. STEVENS     INT PART OF PRELIM MANTISSA
*  14.DEC.80    G.WALKER       REMOVE CALL TO ROUND FROM BINSTR
*
  PAGE
*
****************************************************
*
*    BCDUBL --
*    MULTIPLIES A BCD INTEGER BY 2 AND RETURNS ANY CARRY
*    OUT OF THE MOST SIGNIFICANT DIGIT IN THE CARRY FLAG.
*
*    ON ENTRY:
*     B = NUMBER OF DIGITS (PLUS SIGN) IN BCD NUMBER
*     X = POINTER TO BCD NUMBER
*
*    ON EXIT:
*     C FLAG = CARRY OUT OF MOST SIGNIFICANT DIGIT
*     D,X,Y,U,S ARE UNCHANGED.
*
*     OPERATION:
*     OBVIOUS.
*
*    LOCAL STORAGE:
*     NONE.
*
BCDUBL EQU *
  PSHS    D
  DECB            CHANGE BYTE COUNT TO INDEX
  CLRA            INITIAL CARRY = 0
  WHILE  B,GE,#1    LOOP FOR EACH BCD DIGIT
    RORA        SET CARRY FROM PRECEDING DIGIT
    LDA  B,X
    ROLA        MULTIPLY DIGIT BY 2 AND INSERT
*               CARRY
    BSR  ADJUST      ADJUST FOR DECIMAL DIGIT
    DECB        NEXT DIGIT
  ENDWH
  RORA            PUT HIGH ORDER CARRY INTO CC-REG
*
  PULS    D,PC
  TTL  INCREMENT BCD NUMBER BY ONE
  PAGE
***********************************************
*
*    BCDINC --
*     ADDS 1 TO A BCD INTEGER AND RETURNS THE
*    CARRY OUT OF THE MOST SIGNIFICANT DIGIT IN THE
*    CC-REG.
*
*    ON ENTRY:
*     B = NUMBER OF BYTES IN BCD NUMBER (PLUS SIGN)
*     X = POINTER TO BCD NUMBER
*
*    ON EXIT:
*     CC = CARRY OUT OF MOST SIGNIFICANT DIGIT
*     D,X,Y,U,S ARE UNCHANGED.
*
*    OPERATION:
*     OBVIOUS.
*
*    LOCAL STORAGE:
*     NONE.
*
BCDINC EQU *
  PSHS    D
  DECB            CHANGE BYTE COUNT TO INDEX
  LDA  #1        SET INITIAL CARRY IN
  WHILE A,GE,#1
    IF B,LE,#0
      BRA BINCXT    QUIT IF NO MORE CARRY
    ENDIF
    ADDA B,X        ADD CARRY INTO DIGIT
    BSR  ADJUST      ADJUST FOR DECIMAL DIGIT
    DECB        NEXT MOST SIGNIFICANT DIGIT
  ENDWH
*
BINCXT EQU *
  RORA            PUT CARRY INTO CC-REGISTER
  PULS    D,PC
*
*****************************************************
*
*    ADJUST --
*     THIS ROUTINE ADJUSTS THE UNSIGNED INTEGER IN
*    'A' TO LIE IN THE RANGE 0-9, AND STORES THE
*    RESULTING DECIMAL DIGIT INTO THE BCD STRING
*    POINTED TO BY X AND INDEXED BY B.
*    THE CARRY OUT OF THIS DIGIT IS RETURNED IN 'A'.
*
*    ON ENTRY:
*    A = DIGIT TO BE ADJUSTED
*    B = INDEX INTO BCD STRING
*    X = POINTER TO BCD STRING
*
*    ON EXIT:
*    A = CARRY OUT OF DIGIT
*    CC BASHED.
*    X,Y,U,S UNCHANGED.
*
*    LOCAL STORAGE:
*    NONE.
*
ADJUST EQU *
    IF    A,GE,#10
      SUBA #10
      STA  B,X        ADJUST DIGIT FOR 0<=D<=9
      LDA  #1          AND SHOW CARRY OUT
    ELSE
      STA  B,X        DIGIT IS OK
      CLRA          AND NO CARRY OUT
    ENDIF
    RTS
*
  TTL  BINARY FP INTEGER TO BCD INTEGER CONVERSION
  PAGE
****************************************************
*
*    BINSTR --
*     CONVERTS THE INTEGER PART OF A BINARY FLOATING-
*    POINT NUMBER INTO A STRING OF BCD DIGITS.
*    IT IS ASSUMED THAT 'RPREC' IS SET TO 'EXTENDED PRECISION'
*    BEFORE BINSTR IS CALLED.
*
*    ON ENTRY:
*     B = COUNT OF DIGITS (PLUS SIGN) IN BCD ARRAY
*     X = POINTER TO BCD ARRAY
*     Y = POINTER TO INTERNAL FORMAT FP NUMBER
*
*    ON EXIT:
*     CC,A,B ARE DESTROYED.
*     X,Y,U,S ARE UNCHANGED.
*
*    OPERATION:
*     THE BINARY FP NUMBER IS DENORMALIZED TO PRODUCE A
*    64-BIT BINARY INTEGER IN THE MANTISSA.  THIS BINARY
*    INTEGER IS THEN CONVERTED TO A BCD INTEGER USING METHOD
*    '1B' ON PAGE 281 OF KNUTH, D.E. THE ART OF COMPUTER
*    PROGRAMMING. VOL. 2. SEMINUMERICAL ALGORITHMS. (READING,
*    MASS.: ADDISON-WESLEY), 1973.  THIS IS DONE BY MULTIPLYING
*    THE BCD INTEGER BY 2 FOR EACH ITERATION OF THE LOOP
*    AND ADDING ONE IF THE CORRESPONDING BIT OF THE BINARY
*    INTEGER IS ONE.
*     THE BCD INTEGER CANNOT OVERFLOW, BECAUSE IT REPRESENTS
*    AT MOST 17 DECIMAL DIGITS, WHICH CAN BE REPRESENTED IN
*    60 BINARY BITS.
*
*    SUBROUTINES CALLED:
*     BCDUBL -- MULTIPLIES A BCD INTEGER BY 2
*     BCDINC -- INCREMENTS A BCD INTEGER BY 1
*
*    LOCAL STORAGE:
*     BCDSIZ -- COUNT OF DIGITS (PLUS SIGN) IN BCD INT.
*     LOPCTR -- COUNT FOR DENORMALIZING LOOP
*     LOCSTK -- LOCAL STICKY BYTE FOR ROUNDING
*     BITNDX -- INDEX OF BINARY BIT FOR ACCUMULATING
*     BITMSK -- MASK FOR BIT BEING ACCUMULATED
*     CTLSAV -- SAVE OLD CONTROL BYTE FROM FPCB
*     TMPX    -- TEMP. SAVE X-REG
*
BCDSIZ SET 0
LOPCTR SET 1
LOCSTK SET 2
BITNDX SET 3
BITMSK SET 4
CTLSAV SET 5
TMPX   SET 6
*
BINSTR EQU *
  LEAS -8,S           RESERVE LOCAL STORAGE
  STB  BCDSIZ,S        SAVE BCD INTEGER SIZE
  LDA  SIGN,Y
  IFCC LT
    LDA  #DMINUS
  ENDIF
  STA  0,X           MOVE FP SIGN TO BCD
*
*    ZERO OUT BCD INTEGER
*
  LDA  #0
  LDB  BCDSIZ,S
  DECB
  WHILE  B,GE,#1
    STA  B,X
    DECB
  ENDWH
*
*     DENORMALIZE FP NUMBER UNTIL IT HAS 71 BITS OF INTEGER
*    AND 1 BIT OF FRACTION IN THE MANTISSA.
*
  LDD  EXP,Y
  CMPD    #-1            IF THERE ARE NO INTEGER BITS,
  BLT  BINZER              SET RESULT TO ZERO
  STX  TMPX,S            SAVE POINTER TO BCD BUFFER
  LEAX 0,Y            POINT X TO FP NUMBER
  CLR  STIKY,U
  SUBD #63            CHANGE EXPONENT TO SHIFT COUNT
  COMA                   MUST COMPLEMENT THE DIFFERENCE
  COMB
  ADDD    #1
  LBSR    DENORM             DENORMALIZE FRACTION TO EXTENDED BOUNDARY
  LEAY    FRACT,X          GET FRACT OF OLD Y-REG
  LDX  TMPX,S            AND OLD X-REG
*
*     LOOP TO ACCUMULATE THE 72 BINARY INTEGER BITS INTO THE
*    BCD INTEGER.
*
  LDA  #0
  LDB  A,Y
  WHILE  B,EQ,#0
    CMPA  #TYPE-FRACT-2       STOP AT EXTENDED BYTE BOUNDARY
    BGT   BNSNLP          END IF ALL ARE ZERO
    INCA             SKIP OVER ZERO BYTES OF MANTISSA
    LDB  A,Y
  ENDWH
BNSNLP    EQU  *
  LDB  #$80
  STB  BITMSK,S          START ACCUMULATING BIT7
*
*     NOW ACCUMULATE THE NON-ZERO BITS INTO BCD.
*       ('A' CONTAINS INDEX OF NON-ZERO BYTE.)
*
  WHILE  A,LE,#TYPE-FRACT-2
    LDB  BCDSIZ,S
    LBSR BCDUBL          MULTIPLY BCD BY TWO FOR THIS BIT
    LDB  A,Y
    ANDB BITMSK,S
    IFTST  B,NE,#0
      LDB  BCDSIZ,S         THE BIT IS ONE, SO ADD IT IN
      LBSR BCDINC
    ENDIF
    ROR  BITMSK,S         MOVE TO NEXT BIT
    IFCC CS
      ROR  BITMSK,S         IF NEEDED, MOVE TO NEXT BYTE
      INCA
    ENDIF
  ENDWH
*
*     AND RETURN.
*
  LEAY    -FRACT,Y
BINZER LEAS  8,S
  RTS
*
*
*
*
* PROCEDURE BDCNVT
*
*    BINDEC CONVERTS THE FLOATING- PT. NUMBER
* IN ARG2 TO A DECIMAL FORMAT AND STORES THE BCD
* REPRESENTATION AT THE ADDRESS CONTAINED IN THE
* FIRST 2 BYTES OF THE RESULTS FRECACTION.
*
* ON ENTRY:
*     U - STACK FRAME POINTER
*     S - STACK PIINOINTER
*
* ON EXIT:
*     U,S - UNCHANGED
*     CC,D,X,Y - ARE DESTROYED
*
* LOCAL EQUATES
*
DPLUS EQU  00
DMINUS EQU  $0F
PINF EQU  $0A
NINF EQU  $0B
SNAN EQU  $0C
STRSIZ EQU  26
*
* TEMPORARY STORAGE ON STACK
*
BCDADR EQU  0
NORM   EQU  BCDADR+2
SGNAR  EQU  NORM+1
CTLBYT EQU  SGNAR+1
FCN    EQU  CTLBYT+1
PINDEX EQU  FCN+1
RECNT  EQU PINDEX+1
TV     EQU  RECNT+1
TEMP EQU  0
*
*
BDCNVT EQU  *
*
* CREATE SPACE FOR LOCEAL STORAGE ON THE S STACK
*
 LEAS  -(TV+2),S
*
* SAVE ADDSRESS OF THE USERS BCD ARRAY PRESENTLY
* LOCATED IN FRACTR.
*
 LDX  FRACTR,U              ADDRESS OF BCD STRING
 STX  BCDADR,S
*
* REMEMBER SIGN OF ARG2 AND WHETHER OR NOT ARG2
* IS NORMALIZED
*
 LEAX  ARG2,U
 LDA  FRACT,X              NORMALIZED INFO.
 LDB  SIGN,X              SIGN OT ARGUMENT
 STD  NORM,S              TEMP LOCATION ON STACK
*
* TAKE ABSOLUTE VALUE OF THE INPUT; P := |ARG2|
*
 CLR  SIGN,X
*
* CHECK FOR UNORMALIZED ZEROS AND RETURN A
* PROPERLY SIGNED STRING OF ZEROS.
*
 LBSR  TFRACT              TEST FRACTION
 IFCC  EQ              UNNORMAL ZERO
   LDA    #TYZERO           TAG ARG2 AS A ZERO
   STA    TYPE2,U
   LBSR  OUTNDC           OUTPUT STRING OF ZEROS
*
   LBRA  EXOUTS           EXIT OUTS PROCEDURE
*
 ENDIF
*
*  SAVE P ON THE STACK
*
 LEAS  -ARGSIZ,S           CREATE SPACE
 LEAY  0,S              DESTINATION
*
 LBSR  FPMOVE              MOVE A FLOATING NO.
*
* CHECK PRECISION AND TYPE TO DECIDE IF TO CONTINUE
* WITH PRESENT ALGORITHM AND IF SO HOW TO ASSESS
* THE LOG10(X) OF THE INPUT ARGUMENT.
*
 LDB  RPREC,U              CHECK PRECISION
 IF  B,GE,#EXT               EXTENDED PRECISION
   LBSR  LOG10X           LOG10X AS USUAL
*
 ELSE                  SINGLE OR DOUBLE
   LDA    ARGSIZ+NORM,S
   IFCC  LT              NORMALIZED
     LBSR  LOG10X          LOG10X AS USUAL
*
   ELSE               NOT NORMALIZED
     IF  B,EQ,#SIN          SINGLE
       LEAX  SSMLOG,PCR       LOG10( SMALLEST NORM # SIN )
*
     ELSE              DOUBLE
       LEAX  DSMLOG,PCR       LOG10( SMALLEST NORM # DBL )
*
     ENDIF
     LEAY  ARG2,U
     LBSR  FPMOVE          MOVE LOG10X TO THE RESULT
*
   ENDIF              NORMALIZED
 ENDIF                  EXTENDED
*
** REMEMBER CURRENT ROUNDING MODE, FUNCTION CODE
* AND RPREC PRECISION INDEX.
*
 LDA  [PFPCB,U]           CONTROL BYTE
 LDB  FUNCT,U              FUNCTION CODE
 STD  ARGSIZ+CTLBYT,S          SAVE ON STACK
*
 LDB  RPREC,U              PRECISION INDEX
 STB  ARGSIZ+PINDEX,S         SAVE ON STACK
*
* SET RND MODE TO RZ AND RPREC TO EXT. AND
* FUNCTION CODE TO FCFIXS
*
 ANDA #$FF-(CTLRND+CTLSIZ)    REMOVE RND MODE AND PREC.
 ORA  #RZ+PREXT           SET RZ AND EXT.
 STA  [PFPCB,U]           REPLACE CONTROL BYTE
*
 LDA  #EXT
 STA  RPREC,U              REPLACE PRECISION INDEX
*
 LDA  #FCFIXS
 STA  FUNCT,U              REPLACE FUNCTION INDEX
*
* CONVERT THE LOG10(P) TO A  BINARY INTEGER
*
 LBSR  FFIX              FLOATING TO INTEGER CONVERSION
*
* COMPUTE V := IFIX(Q)+1-K
*
 CLR  TPARAM,U              K IN TPARAM+1
* VALIDATE K
 LDD TPARAM,U
 IF D,GT,#MAXK
   LDA #7         INVALID OPERATION=7
   LBSR IOPSET
   LDD #MAXK              SET K TO MAX AND CONTINUE
   STD TPARAM,U
 ENDIF
 LDD FRACTR,U              RESULT OF FFIX(Q)
 ADDD  #1
 SUBD  TPARAM,U
 STD  ARGSIZ+TV,S           SAVE V ON STACK
*
* START OF ADJUSTMENT LOOP FOR W
*
* INITIALIZE COUNTER FOR NO. OF PASSES THROUGH LOOP
*
 CLR  ARGSIZ+RECNT,S
*
GETW EQU  *
*
*
* SET RND MOCE TO NEAREST
*
 LDA  ARGSIZ+CTLBYT,S          ORIGINAL CONTROL BYTE
 ANDA #$FF-(CTLRND+CTLSIZ)    REMOVE ROUND INFO.
 ORA  #RN+PREXT           INSERT NEW INFO.
 STA  [PFPCB,U]           REPLACE CONTROL BYTE
*
* IF V IS NEGATIVE  NEGATE V
*
 LDD  ARGSIZ+TV,S          GET V
 IFCC  LT              V IS NEGATIVE
   COMA
   COMB
   ADDD  #1
*
 ENDIF
*
* COMPUTE  10|V
*
 LBSR  PWRTEN
*
* MOVE 10|V TO ARG2 AND P TO ARG1; CHECK THE SIGN
* OF V, IF V IS POSITIVE COMPUTE W := P/10|V
* ELSE IF V IS NEGATIVE COMPUTE W:= P*10|V.
*
 LEAX  RESULT,U           SOURCE
 LEAY  ARG2,U              DESTINATION
*
 LBSR  FPMOVE              MOVE 10|V TP ARG2
*
 LEAX  TEMP,S              SOURCE
 LEAY  ARG1,U              DESTINATION
*
 LBSR  FPMOVE              MOVE P TO ARG1
*
* ZERO OUT STACK FRAME RESULT
*
 LEAX  RESULT,U
 LDB  #CLRALL              CLEAR ALL OF ARGUMENT
 LBSR  CLRES
*
* CHECK SIGN OF V
*
 LDA  ARGSIZ+TV,S          SIGN OF V
 IFCC  GE              SIGN POSITIVE
   LBSR  FDIV              FLOATING DIVIDE
*
 ELSE                  SIGN NEGATIVE
   LBSR  FMUL              FLOATING MULTIPLY
*
 ENDIF
*
* RESORE ORIGINAL ROUND MODE
*
 LDA  ARGSIZ+CTLBYT,S          ORIGINAL CONTROL BYTE
 STA  [PFPCB,U]           RESTORE CONTROL BYTE
*
* RESTORE ORIGINAL SIGN AND TAKE THE INTEGER PART
*
 LEAX  RESULT,U           PRELIMINARY MANTISSA
 LEAY  ARG2,U              INPUT TO INT PART
 LBSR  FPMOVE              MOVE MANTISSA TO ARG2
*
 LDA  ARGSIZ+SGNAR,S          ORIGINAL SIGN
 STA  SIGN,Y
*
 LBSR  GETINT              TAKE INTEGER PART
*
 CLR  SIGNR,U              CLEAR SIGN
*
* CHECK SPECIAL CASES
*
 LDA  ARGSIZ+NORM,S          PUT NORM INFO IN TYPE BYTE
 STA  TYPER,U
*
 LDD  ARGSIZ+TV,S          V IS ARGUMENT TO CHEKW
*
 BSR  CHEKW            SPECIAL CASE CHECKER/HANDLER
*
* REPLACE V WITH POSSIBLY UPDATED VALUE
*
 STD  ARGSIZ+TV,S
*
* IF THE CARRY IS SET AND IF THE VALUE WAS ORIGINALLY
* NORMALIZED AND HAS NOT GONE THROUGH THE ADJUSTMENT
* PROCEDURE THEN RECALCULATE W.
*
 IFCC  CS              W FAILS CHECK W PROCEDURE
   INC    ARGSIZ+RECNT,S          KEEP COUNT OF # OF TIMES FAILED
   LDA    ARGSIZ+NORM,S          CHECK NORMALIZATION OF ARG2
   IFCC  LT              ARG2 NORMALIZED
     LDA  ARGSIZ+RECNT,S      CHECK COUNT
     IF  A,LE,#01          FIRST PASS
       BRA  GETW          RECALCULATE W
*
     ENDIF
*
   ELSE               ARG2 NOT NORMALIZED
     BRA  GETW              RECALCULATE
*
   ENDIF
 ENDIF
*
* CLEAR TEMP LOCATION OF P FROM THE STACK
*
 LEAS  ARGSIZ,S
*
* CONVERT W AND V TO BCD STRINGS I AND E RESPECTIVELY
*
* CONVERT W TO I
*
*
* SET SIGN OF W TO THAT OF ORIGINAL ARGUMENT
*
 LDA  SGNAR,S              SIGN ORIGINAL ARGUMENT
 STA  SIGNR,U
*
 LEAY  RESULT,U           W IN INTERNAL FORMAT
 LDX  BCDADR,S              ADDRESS OF BCD ARRAY
 LEAX  SF,X              POINT TO BCD FRACTION
 LDB  #SIGDIG+1           LENGHT OF BCD FRACTION+1
*
 LBSR  BINSTR              BINARY TO STRING CONVERSION
*
* CONVERT V TO E
*
* KLUDGE UP V AS A FLOATING OPERAND
*
* ZERO OUT RESULT ON THE STACK FRAME
*
 LEAY  RESULT,U
 CLRB
 WHILE    B,LT,#ARGSIZ
   CLR    B,Y
   INCB
*
 ENDWH
*
 CLR  SIGN,Y             ASSUME SIGN POSITIVE
 LDD  TV,S              GET V
 IFCC  LT              V IS NEGATIVE
   COMA
   COMB
   ADDD  #1
*
   COM    SIGN,Y             SET SIGN NEGATIVE
*
 ENDIF
*
 STD  FRACT,Y              INSERT INTO FRACTION OF ARG1
 LDD  #EXPSIZ-1           INSET CORRECT EXPONENT
 STD  EXP,Y
*
 LDX  BCDADR,S              ADDRESS OF BCD ARRAY
 LDB  #EXPDIG+1           SIZE OF BCD EXP.+SIGN
*
 LBSR  BINSTR              BINARY TO STRING CONVERSION
*
* SET P ( NO. OF DIGITS TO THE RIGHT OF THE DECIMAL PT.)
* TO ZERO.
*
 CLR  POFF,X         CLEAR P FIELD IN BCD STRING
*
EXOUTS    EQU  *         OUTS EXIT POINT .
*
*
 LDA  TSTAT,U
 ANDA  #$FF-ERRINX          CLEAR POSSIBLE INEXACT RESULT FLAG
 STA  TSTAT,U
*
* REMOVE TEMPS FROM STACK
*
 LEAS  (TV+2),S
*
 RTS
*
*
* PROCEDURE  CHEKW
*
*    CHEKW HANDLES ADJUSTING W FOR THE FOLLOWING
* SPECIAL CASES WHEN DOING A BINARY TO DECIMAL
* CONVERSION. THE SPECIAL CASES ARE:
*
*  1) IF W = 10|K , THEN INCREMENT V AND DIVIDE
*     W BY 10( EXACTLY )
*
*  2) IF W >= (10|K)+1 , THEN INCREMENT V AND
*     RECALCULATE W.
*
*  3) IF W <= (10|(K-1))-1 , THEN DECREMENT V
*     AND RECALCULATE W.
*
* ON ENTRY: X - POINTS TO W ON THE STACK FRAME
*        D - CONTAINS V
*
* ON EXIT: X - POINTS TO W ON THE STACK FRAME
*       D - CONTAINS UPDATED VALUE OF V
*
*
* LOCAL EQUATES FOR TEMPS ON S STACK
*
TK    EQU  0
FUNC  EQU  TK+2
REFLG  EQU  FUNC+1
OKFLG  EQU  REFLG+1
TMPW EQU OKFLG+1
TVSPC EQU  TMPW+ARGSIZ          TEMPORARY V
*
CHEKW EQU  *
*
 PSHS  X,D              SAVE CALLERS REGS.
*
* SAVE W ON THE STACK
*
 LEAS  -ARGSIZ,S          CREATE SPACE
*
 LEAX  RESULT,U           SOURCE
 LEAY  0,S              DESTINATION
 LBSR  FPMOVE              MOVE W TO TEMP
*
* CREATE SPACE FOR TEMPS OM THE STACK
*
 LEAS  -(OKFLG+1),S
*
* INITIALIZE FLAGS; $00=TRUE, $FF=FALSE
*
 CLR  OKFLG,S              W IS OK FLAG  SET TRUE
 LDA  #FALSE              W NEEDS RECALCULATING SET FALSE
 STA  REFLG,S
*
* TEMPORARILY CHANGE FUNCTION CODE TO PREDICATE
* COMPARE AND PRECISION TO EXTENDED.
*
 LDA  FUNCT,U              GET FUNCTION CODE
 STA  FUNC,S              SAVE IT
 LDA  #FCPCMP              REPLACE WITH
 STA  FUNCT,U              PREDICATE COMPARE
*
 LDA  #EXT              EXTENDED RPREC INDEX
 STA  RPREC,U
*
* SAVE K SINCE TPARAM NEEDED FOR COMPARE
*
 LDD TPARAM,U              GET K
 STD  TK,S              SAVE IT
*
* CASE 1:  W = 10|K
*
* CALCULATE 10|K
*
 LBSR  PWRTEN
*
* MOVE 10|K TO ARG2
*
 LEAX  RESULT,U           SOURCE
 LEAY  ARG2,U              DESTINATION
 LBSR  FPMOVE
*
* MOVE W TO ARG1
*
 LEAX  TMPW,S              SOURCE
 LEAY  ARG1,U              DESTINATION
 LBSR  FPMOVE
*
* COMPARE W TO 10|K
*
 LDX  CASE1,PCR           SET UP PARAMETERS
 STX  TPARAM,U
*
 LBSR  ARG1UN
*
* IF W = 10|K THEN DECREMENT K AND RECALCULATE
* 10|K    AND INCREMENT V.
*
 LDA  FRACTR,U              RESULT OF THE COMPARE
 IFCC  EQ              W = 10|K
   LDD    TK,S              GET K
   DECD               DECREMENT K
*
   LBSR  PWRTEN           RECALCULATE W
*
   LDD    TVSPC,S           INCREMENT V
   INCD
   STD    TVSPC,S
*
   LDA    #FALSE              SET OK FLAG FALSE
   STA    OKFLG,S
*
   LBRA  EXITSP
*
 ENDIF
*
*
* CASE 2:  W >= (10|K)+1
*
* ASSUME 10|K STILL IN ARG2
*
* PUT 1 IN ARG1
*
 LEAX  ONE,PCR              FLOATING ONE CONSTANT
 LEAY  ARG1,U              DESTINATION
 LBSR  FPMOVE
*
 LBSR  FADD              COMPUTE (10|K)+1
*
* MOVE (10|K)+1 T0 ARG2
*
 LEAX  RESULT,U           SOURCE
 LEAY  ARG2,U              DESTINATION
 LBSR  FPMOVE
*
* MOVE W TO ARG1
*
 LEAX  TMPW,S              SOURCE, TEMP W
 LEAY  ARG1,U              DESTINATION
 LBSR  FPMOVE
*
* COMPARE W TO (10|K)+1
*
 LDX  CASE2,PCR           SET UP PREDICATES
 STX  TPARAM,U
*
 LBSR  ARG1UN
*
* IF W >= (10|K)+1 THEN INCREMENT V AND
* RECALCULATE W.
*
 LDA  FRACTR,U              RESULT OF THE COMPARE
 IFCC  EQ              W >= (10|K)+1
   LDD    TVSPC,S           INCREMENT V
   INCD
   STD    TVSPC,S
*
   CLR    REFLG,S           SET RECALCULATE FLAG TRUE
   LDA    #FALSE              SET OK FLAG FALSE
   STA    OKFLG,S
*
   BRA    EXITSP
*
 ENDIF
*
* CASE 3:  W <= (10|(K-1))-1
*
* CALCULATE  (10|(K-1))-1
*
 LDD  TK,S              GET K
 DECD                  DECEEMENT K
*
 LBSR  PWRTEN              CALCULATE 10|(K-1)
*
* MOVE 10|(K+1) TO ARG1
*
 LEAX  RESULT,U           SOURCE
 LEAY  ARG1,U              DESTINATION
 LBSR  FPMOVE
*
* MOVE ONE TO ARG2
*
 LEAX ONE,PCR              SOURCE
 LEAY  ARG2,U              DESTINATION
 LBSR  FPMOVE
*
 LBSR  FSUB              CALCULATE  (10|(K-1))-1
*
* MOVE    (10|(K-1))-1 TO ARG2
*
 LEAX  RESULT,U           SOURCE
 LEAY  ARG2,U              DESTINATION
 LBSR  FPMOVE
*
* MOVE W TO ARG1
*
 LEAX  TMPW,S              START OF TEMP W
 LEAY ARG1,U              DESTINATION
 LBSR  FPMOVE
*
* COMPARE W TO (10|(K-1))-1
*
 LDX  CASE3,PCR           SET UP PREDICATES
 STX  TPARAM,U
*
 LBSR  ARG1UN
*
* IF W <= (10^(K-1))-1 AND ARG2 WAS ORIGINALLY
* UNNORMALIZED THEN DECREMENT V AND RECALCULATE
* W.
*
 LDA  FRACTR,U              RESULT OF COMPARE
 IFCC  EQ              W <=  (10|(K-1))-1
   LDA    TMPW+TYPE,S        NORM. INFO IN TYPE BYTE
   IFCC  LT               W NORMALIZED
     LDD  TVSPC,S        DECREMENT V
     DECD
     STD  TVSPC,S
*
     CLR  REFLG,S        SET RECALCULATE W FLAG TRUE
     LDA  #FALSE        SET OK FLAG FALSE
     STA  OKFLG,S
*
   ENDIF
 ENDIF
*
*
EXITSP EQU  *
*
* RESTORE FUNCTION CODE
*
 LDA  FUNC,S
 STA  FUNCT,U
*
 LDD  TK,S
 STD  TPARAM,U
*
* CHECK TO SEE IF ANY OF THE SPECIAL CASES WERE
* MET; IF NOT THEN W IS OK AND SHOULD BE RETURNED
* IN THE STACK FRAME RESULT.
*
 LDA  OKFLG,S              FLAG TRUE IF ALL TESTS FAIL
 IFCC  EQ              W IS OK
   LEAX  TMPW,S           SOURCE
   LEAY  RESULT,U          DESTINATION
   LBSR  FPMOVE           MOVE W TO THE RESULT
*
 ENDIF                  W IS OK
*
* SET CARRY APPROPRIATELY DEPENDING ON WHETHER
* OR NOT RECALCULATION OF W  IS NECCESSARY.
*
 LDA  REFLG,S
 COMA                  REMEMBER    TRUE = 00
 RORA
*
* CLEAN UP STACK
*
 LEAS  ARGSIZ+OKFLG+1,S
*
 PULS  X,D,PC              RESTORE AND RETURN
*
* PREDICATE EQUATES
*
CASE1 FDB  $0422
CASE2 FDB  $0C22
CASE3 FDB  $0622
*
* SMALL LOG10(X) CONSTANTS
*
SSMLOG FCB  $80,00,$05,$98,$EC,$59
       FCB  $4F,$F1,$D8,$57,$AA,00
       FCB  TYNORM
*
DSMLOG FCB  $80,00,$08,$99,$FA,$12
       FCB  $5E,$5A,$91,$03,$9B,00
       FCB  TYNORM
*
*
*
 PAG
*
*
***********************************************************
*
*  PROCEDURE OUTNDC
*
*      HANDLES OUTPUTING OF NON-DECIMAL STRINGS
* AND ZEROS . THE NON-DECIMAL STRINGS ARISE WHEN
* A BINARY TO DECIMAL CONVERSION IS PERFORMED ON
* A NAN OF A +/- INFINITY.
*
* ON ENTRY: ARG2 IS THE INPUT ARGUMENT
*        TYPE BYTE IS SET CORRECTLY
*        U - STACK FRAME POINTER
*
* ON EXIT: BCD STINGS FIST LOCATION CONTAINS
*       SPECIAL CODE REPRSENTING +/-
*       INFINITY OR A NAN
*       IF A NAN THE NEXT 4 BYTES IN THE
*       STRING CONTAIN THE NAN ADDRESS.
*       U - UNCHANGED
*       D,X,Y - DESTROYED
*
OUTNDC EQU  *
*
* ZERO OUT BCD STRING
*
  LDX  FRACTR,U         GET ADDRESS OF STRING
  LDA  #STRSIZ
  WHILE  A,GT,#0
    DECA
    CLR  A,X
*
  ENDWH
*
* DECIDE WHICH TO TAKE
*
  LDA  TYPE2,U            CHECK TYPE
  IF  A,EQ,#TYINF        TYPE INFINITY
    LDA  SIGN2,U        CHECK SIGN
    IFCC  GE            SIGN POSITIVE
      LDA  #PINF        SIGNAL POSITIVE INFINITY

*
    ELSE
      LDA  #NINF        SIGNAL MINUS INFINITY
*
    ENDIF
    STA  0,X
*
  ELSE
  IF  A,EQ,#TYNAN         TYPE NAN
    LDA  #SNAN             SIGANL NAN
    STA  0,X
*
* ALIGN NAN ADDRESS WITH BYTE BOUNDARY
*
    LEAY  FRACT2,U
    LDB  #2
    WHILE  B,GT,#0
      LSHIFT  0,Y,3
      DECB
*
    ENDWH
*
* INSERT NAN ADRESS INTO BCS STRING
*
    CLRB
    WHILE  B,LT,#EXPDIG
      INCB
      LDA  0,Y               GET MSBYTE OF ADDRESS
      LSRA
      LSRA
      LSRA
      LSRA
      STA  B,X                INSERT A HEX CHAR.
*
      INCB
      LDA  0,Y
      ANDA  #$0F
      STA  B,X                INSERT A HEX CHAR.
*
      LEAY  1,Y             INCREMENT POINTER
*
    ENDWH
*
  ELSE
  IF  A,EQ,#TYZERO             TYPE ZERO
    LDA  SIGN2,U            CHECK SIGN
    IFCC  GE                POSITIVE
      LDA  #DPLUS
*
    ELSE                NEGATIVE
      LDA  #DMINUS
*
    ENDIF
    STA  SF,X                 INSERT CORRECT SIGN
*
  ENDIF
  ENDIF
  ENDIF
*
  RTS                   RETURN